Pensieve Header: Wheeled Semi-Symmetrized calculus in the 2D quotient.

Continues “Semi-Symmetrized 2D Calculus.nb”, “A 2D B-Picture, IV.nb”, uses computations from “BCH in Blobs.nb”.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\w-Computations"]

ar[i_,j_] := t[i]h[j]

μCollect[μ_] := Collect[μ, _h, Collect[#, _t, FullSimplify]&];
SetAttributes[μForm, Listable];
μForm[μ_] := Module[
{tails, heads, mat},
tails = Union[Cases[μ, t[s_] :> s, Infinity]];
heads = Union[Cases[μ, h[s_] :> s, Infinity]];
mat = Outer[FullSimplify[Coefficient[μ, h[#1] t[#2]]]&, heads, tails];
PrependTo[mat, t /@ tails];
mat = Prepend[Transpose[mat],
Prepend[h /@ heads, μ /. (h[_]|t[_]) -> 0]
];
MatrixForm[mat]
]

Heads Works

hm[x_,y_,z_][μ_] := Module[
{ξ, η},
ξ = D[μ, h[x]];
η = D[μ, h[y]];
μCollect[(μ /. h[x|y]->0) + ξ h[z] + (1+ξ /. t[s_]:>c[s])η h[z]]
];
hΔ[z_, x_, y_][μ_] := μCollect[μ /. h[z] -> h[x]+h[y]];
hS[x_][μ_] := Module[{β},
β = 1 + D[μ, h[x]] /. t[s_]:>c[s];
μCollect[μ /. h[x] -> -h[x]/β]
];

hm[3,4,5][ar[1,3]+ar[2,4]]

hm[3,4,5][ar[1,3]+ar[2,4]] // μForm

Associativity of Heads Multiplication

μ1=α1 ar[1,1]+α2 ar[2,2]+α3 ar[3,3]

μ1 // μForm

μ1 // hm[1,2,1] // μForm

(t1=μ1 // hm[1,2,1] // hm[1,3,1]) // μForm

(t2 = μ1 // hm[2,3,2] // hm[1,2,1]) // μForm

(t1-t2 ) // μForm

Compatibility of m and Δ

μ=α1 ar[1,1]+ α2 ar[2,2];
{
μ // hΔ[1,1,3] // hΔ[2,2,4] // hm[1,2,1] // hm[3,4,2],
μ // hm[1,2,1] // hΔ[1,1,2]
} // μForm

The Antipode Property

{
α ar[1,1] // hΔ[1,1,2] // hS[2] // hm[1,2,1],
α ar[1,1] // hΔ[1,1,2] // hS[2] // hm[2,1,1]
}

Factorization

hfac[z_, xtails_List -> x_, y_][μ_] := Module[
{ytails},
ytails = Complement[
Union[Cases[μ, t[s_] :> s, Infinity]],
xtails
];
hfac[z,xtails -> x, ytails -> y][μ]
];
hfac[z_, x_,  ytails_List -> y_][μ_] := Module[
{xtails},
xtails = Complement[
Union[Cases[μ, t[s_] :> s, Infinity]],
ytails
];
hfac[z,xtails -> x, ytails -> y][μ]
];
hfac[z_, xtails_List -> x_, ytails_List -> y_][μ_] := Module[
{ζ, ξ, η},
ζ = D[μ, h[z]];
ξ = ζ /. ((t[#]->0)& /@ ytails);
η = ζ /. ((t[#]->0)& /@ xtails);
μCollect[μ-h[z]ζ + h[x]ξ + h[y]η/(1+ξ /. t[s_]->c[s])]
]

hm[3,4,5][ar[1,3]+ar[2,4]] // μForm

hm[3,4,5][ar[1,3]+ar[2,4]] // hfac[5,{1}->3, 4]

Conjugation

(μ2 = (Subscript[α, 1]) ar[1,1] + (Subscript[α, 2]) ar[2,1] + (Subscript[α, 3]) ar[2,2] + (Subscript[α, 4]) ar[2,3]) // μForm

Warning: Presently conj is designed to work only in the no-feedback case.

conj[y_,x_][μ_] := Module[
{ξ, η, a},
ξ = D[μ, h[x]];
η = D[μ, t[y]];
a = 1 + ξ /. t[s_] :> c[s];
μCollect[(μ /. t[y] -> a t[y]) -c[y] ξ η]
];

μ2 // conj[1,2] // μForm

(t1 = μ2 // conj[1,2] // conj[1,3] // hm[2,3,2]) // μForm

(t2 = μ2 //  hm[2,3,2] // conj[1,2]) // μForm

t1==t2

“4T”

Riffle[
ComposeList[
ops={conj[2,1], hΔ[1,1,3], hm[2,3,2], hΔ[1,1,3], hS[3], hm[3,2,2]},
(Subscript[α, 1]) ar[1,1] + (Subscript[α, 2]) ar[2,2]
]// μForm,
ops
]

(Subscript[α, 1]) ar[1,1] + (Subscript[α, 2]) ar[2,2](Exp[c[2]]-1)/c[2] // conj[2,1] // hΔ[1,1,3] // hm[2,3,2]//hΔ[1,1,3] // hS[3] // hm[3,2,2]// μForm

Riffle[
ComposeList[
ops={hΔ[1,1,3], hm[2,3,2], hΔ[1,1,3], hS[3], hm[3,2,2]},
(Subscript[α, 1]) ar[1,1] + (Subscript[α, 2]) ar[1,2]
]// μForm,
ops
]